home *** CD-ROM | disk | FTP | other *** search
/ The Best of MacTutor - S…e Code for Volumes 1 to 5 / The Best of MacTutor - Source Code for Volume 1-5 (Wayzata Technology)(6031)(1990).bin / Source Code / #09 (Jun 86) / Forth source code / CRT saver.VBL < prev   
Text File  |  1986-04-08  |  7KB  |  292 lines
  1. ( CRT saver task for installation into VBLTask queue, 4.4.86 JL )
  2. only forth definitions
  3. also assembler also mac
  4.  
  5. hex
  6. 29A constant JGNEFilter
  7. 824 constant screenbase
  8. 904 constant currentA5
  9. 9EE constant grayRgn
  10. 16A constant Ticks
  11.  74 constant screenbits
  12.  10 constant portrect
  13. FFFFFFFF constant minusone
  14.  
  15. .TRAP   _drawmenubar    $A937
  16. .TRAP   _frontwindow    $A924
  17. .TRAP   _paintbehind    $A90D
  18. .TRAP   _newptr,sys     $A51E
  19. .TRAP   _showcursor     $A853
  20.  
  21. CODE save.regs
  22.     MOVE.W  SR,-(A7)
  23.     MOVEM.L A1-A6/D0-D7,-(A7)
  24.     RTS
  25. END-CODE    MACH
  26.  
  27. CODE restore.regs
  28.     MOVEM.L (A7)+,A1-A6/D0-D7
  29.     MOVE.W  (A7)+,SR
  30.     RTS
  31. END-CODE    MACH
  32.  
  33. CODE getA1
  34.     MOVE.L  A1,-(A6)
  35.     RTS
  36. END-CODE    MACH
  37.  
  38. decimal
  39.  
  40. header START
  41.  
  42. ( *** we need two local stacks after the relocation *** )    
  43.  
  44. header GNE.stack 100 allot
  45.  
  46. CODE setup.GNE.stack
  47.     LEA -8(PC),A6   ( GNE stack grows downward from here )
  48.     RTS
  49. END-CODE
  50.  
  51. header VBL.stack 100 allot
  52.  
  53. CODE setup.VBL.stack
  54.     LEA -8(PC),A6   ( VBL stack grows downward from here )
  55.     RTS
  56. END-CODE
  57.  
  58. ( *** define port structure + some global variables *** )
  59.  
  60. header screenport
  61.      2 allot ( device )
  62.     14 allot ( bitmap )
  63.      8 allot ( portrect   )
  64.     84 allot ( remaining bytes )
  65.  
  66. header myevents
  67.     2 allot ( code )
  68.     4 allot ( message )
  69.     4 allot ( when )
  70.     4 allot ( where )
  71.     2 allot ( modifiers )
  72.  
  73. ( *** VBL queue element to be installed *** )
  74.  
  75. header VBLqelem
  76.     4 allot ( qLink )
  77.     2 allot ( qType )
  78.     4 allot ( vblAddr )
  79.     2 allot ( vblCount )
  80.     2 allot ( vblPhase )
  81.  
  82.  1 constant vType
  83.  4 constant qType
  84.  6 constant vblAddr
  85. 10 constant vblCount
  86. 12 constant vblPhase
  87.      
  88. ( *** GetNextEvent filter proc definitions *** )
  89.  
  90. header SavedJGNEFilter 4 allot
  91. header dark  4 allot     
  92. header last.action 4 allot
  93. header max.ticks   4 allot
  94.    3600 ' max.ticks !  ( 1 min in ticks )
  95.  
  96.  
  97. : GNEIntfc
  98.     save.regs
  99.     setup.GNE.stack
  100.     
  101.     getA1 w@ ( event received? )
  102.       IF ticks @ ['] last.action !
  103.         ['] dark @
  104.         IF 
  105.             0 ['] dark !
  106.             _drawmenubar
  107.             CLR.L    -(A7)
  108.             _frontwindow 
  109.             grayrgn @
  110.             MOVE.L   (A6)+,-(A7)
  111.             _paintbehind
  112.             _showcursor
  113.         THEN
  114.       THEN
  115.  
  116.     ['] SavedJGNEFilter @
  117.     MOVE.L  (A6)+,A0
  118.     restore.regs
  119.     JMP     (A0)
  120. ;
  121.     
  122.  
  123. ( *** definitions for VBLtask that does the blanking *** )
  124.  
  125. : blankout 
  126.     call hidecursor
  127.     screenbase @ 21888 + 
  128.     screenbase @
  129.     BEGIN
  130.         minusone over !
  131.         4 + 2dup < 
  132.     UNTIL 2drop 
  133.     1 ['] dark !
  134. ;
  135.  
  136. : one.run
  137.     save.regs
  138.     setup.VBL.stack
  139.     ticks @ ['] last.action @ - ['] max.ticks @ >
  140.     ['] dark @ 0=
  141.     AND
  142.     IF  blankout  THEN
  143.     60 ['] VBLqelem vblCount + w! ( reschedule )
  144.     restore.regs
  145. ;
  146.  
  147. header END
  148.  
  149.  
  150. ( *** installation of CRT blanker task 'one.run' into VBL queue *** )
  151.  
  152. variable blockoffset
  153.  
  154. : get.sys.block  
  155.     ['] end ['] start - 
  156.     MOVE.L (A6)+,D0
  157.     _newptr,sys ( get memory block in system heap )
  158.     MOVE.L A0,-(A6)
  159. ;
  160.     
  161. : install.blanker   { | pointer offset -- }
  162.     get.sys.block   -> pointer
  163.     pointer IF
  164.         0 ['] dark !
  165.         ticks @ ['] last.action !
  166.         pointer ['] start -  -> offset
  167.         offset blockoffset !
  168.         ['] start pointer ['] end ['] start - cmove
  169.     ( now make all the moves on the relocated block )
  170.         ['] VBLqelem offset +
  171.         dup qtype + vtype swap w!
  172.         dup vblAddr + ['] one.run offset + swap !
  173.         dup vblCount + 60 swap w!
  174.         dup vblPhase + 5 swap w!
  175.         call Vinstall drop
  176.     ELSE ." Not enough system heap for installation." cr
  177.     THEN
  178. ;
  179.  
  180. : install.GNEfilter
  181.     JGNEFilter @ ['] SavedJGNEFilter blockoffset @ + !
  182.     ['] GNEIntfc blockoffset @ + JGNEFilter !
  183. ;
  184.  
  185. : remove.blanker
  186.     ['] VBLqelem blockoffset @ + call Vremove drop
  187. ;
  188.  
  189. : remove.GNEfilter
  190.     ['] SavedJGNEFilter blockoffset @ +  JGNEFilter ! 
  191. ;
  192.  
  193. ( *** alert boxes to make the thing a little more Mac-like *** )
  194. new.window startalert
  195. 50 100 330 400  startalert bounds
  196. alert invisible noclosebox nogrowbox startalert items 
  197. 700 800 terminal starter    
  198.  
  199. new.control install
  200. " Install" install title
  201. 250 50 270 100 install bounds
  202. pushbutton visible 1 0 install items
  203.  
  204. new.control cancel
  205. " Cancel" cancel title
  206. 250 200 270 250 cancel bounds
  207. pushbutton visible 1 0 cancel items
  208.  
  209. new.window installedalert
  210. 50 100 200 400  installedalert bounds
  211. alert invisible noclosebox nogrowbox installedalert items 
  212. 700 800 terminal installed    
  213.  
  214. new.control ok
  215. " OK" ok title
  216. 110 120 130 170 ok bounds
  217. pushbutton visible 1 0 ok items
  218.  
  219. : finish.control.handler 2drop bye ;
  220. : setup.finish.controls ['] finish.control.handler control-vector ! ;    
  221. : go.finish
  222.     activate
  223.     installedalert call showwindow
  224.     installedalert call selectwindow
  225.     setup.finish.controls
  226.     cr cr
  227.     ." CRT saver successfully installed." cr 
  228.     begin pause again
  229. ;
  230.  
  231. : do.install
  232.     install.blanker
  233.     install.GNEfilter
  234.     startalert call hidewindow
  235.     installed go.finish 
  236. ;
  237.  
  238. : do.cancel bye ;
  239.  
  240. : start.control.handler
  241.     CASE
  242.     install @ of do.install endof
  243.     cancel @  of do.cancel  endof
  244.     2drop
  245.     endcase
  246. ;
  247.  
  248.  
  249. : setup.start.controls  ['] start.control.handler  control-vector ! ;
  250.  
  251. : go.starter
  252.     activate
  253.     startalert call showwindow
  254.     startalert call selectwindow
  255.     setup.start.controls
  256.     ."      CRT saver installation program" cr
  257.     ."     © 1986 by J. Langowski / MacTutor" cr cr
  258.     ." This program  installs  a vertical blanking task" cr
  259.     ." that  will  automatically  darken  the screen of" cr
  260.     ." your Macintosh  when  no activity  (mouseclicks," cr
  261.     ." keystrokes)  are  detected  for  one minute.  As" cr
  262.     ." soon as you press a key or click the mouse, your" cr
  263.     ." screen will be restored. " cr
  264.     ." This program in its entirety  was written in the" cr
  265.     ." Forth-83 multitasking Mach1 system. Mach1 is di-" cr
  266.     ." stributed by: Palo Alto Shipping,  P.O.Box 7430," cr
  267.     ." Menlo Park, CA 94029, phone (800) 44-FORTH." cr  
  268.     ." The CRT saver patches the  GetNextEvent routine," cr
  269.     ." which is inherently dangerous to do. So far, the" cr
  270.     ." program  has been  benign in  all  cases tested." cr
  271.     ." However, the author  can take  no responsibility" cr
  272.     ." for any  malfunctions of this little gem nor for" cr 
  273.     ." any consequences such as crashed disks." cr cr
  274.     ." If you still want to install, click Install." 
  275.     begin pause again
  276. ;
  277.  
  278. : init-structures
  279.     startalert add
  280.     startalert starter build
  281.     startalert install add
  282.     startalert cancel add
  283.     installedalert add
  284.     installedalert installed build
  285.     installedalert ok add
  286. ;
  287. : CRTsaver 
  288.     init-structures
  289.     starter go.starter 
  290. ;
  291.  
  292.